home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / vector.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-07-11  |  19.6 KB  |  455 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; Permutation vectors.
  28. ;;;
  29.  
  30. (in-package 'pcl)
  31.  
  32. (defmacro instance-slot-index-from-slots-layout (slots-layout slot-name)
  33.   `(locally (declare #.*optimize-speed*)
  34.      (let ((slots-left ,slots-layout))
  35.        (if slots-left
  36.            (block nil
  37.              (let ((index 0))
  38.                (declare (type index index))
  39.                (tagbody
  40.                  begin-loop
  41.                   (if (eq (car slots-left) ,slot-name)
  42.                       (go return-index))
  43.                   (setf index (the index (1+ index)))
  44.                   (if (null (setf slots-left (cdr slots-left)))
  45.                       (return NIL))
  46.                   (go begin-loop)
  47.                  return-index)
  48.                index))))))
  49.  
  50. (defmacro instance-slot-index (wrapper slot-name)
  51.   `(instance-slot-index-from-slots-layout
  52.       (wrapper-instance-slots-layout ,wrapper) ,slot-name))
  53.  
  54.  
  55.  
  56. ;;;
  57. ;;;
  58. ;;;
  59. (defun optimize-slot-value-by-class-p (class slot-name type)
  60.   (let ((slotd (find-slot-definition class slot-name)))
  61.     (and slotd 
  62.      (or (not (eq *boot-state* 'complete))
  63.          (slot-accessor-std-p slotd type)))))
  64.  
  65. (defun optimize-generic-function-call (form required-parameters env)
  66.   (declare (ignore env required-parameters))
  67.   form
  68.   #||
  69.   (let* ((gf-name (car form))
  70.      (gf (gdefinition gf-name))
  71.      (arg-info (gf-arg-info gf))
  72.      (metatypes (arg-info-metatypes arg-info))
  73.      (nreq (length metatypes))
  74.      (applyp (arg-info-applyp arg-info)))
  75.     (declare (type index nreq))
  76.     (declare (ignore applyp))
  77.     (if (or (zerop nreq)
  78.         (not (<= nreq (length (cdr form))))
  79.         (not (every #'(lambda (arg mt)
  80.                 (declare (ignore mt))
  81.                 (when (consp arg)
  82.                               (setq arg (un-the arg)))
  83.                 (and (symbolp arg)
  84.                  (memq arg required-parameters))
  85.                 (let ((class-name (caddr (variable-declaration 
  86.                               'class arg env))))
  87.                   (and class-name (not (eq 't class-name)))))
  88.             (cdr form) metatypes)))
  89.     form
  90.     form))||#) ;`(maybe-fast-gf-call ,(car form) ,(cdr form))
  91.  
  92.  
  93. ;; For calls to a gf:
  94. ; gf-call-info: (gf call-info-vector . gf-function-vector)
  95. ; call-info-vector:     #(call-info1 ... call-infon)
  96. ; gf-function-vector:   #(function1 ... functionn)
  97. ; --> once an entry is made in call-info-vector, it is never moved or removed
  98. ; call-info:            (gf . arg-types)
  99. ; arg-type:             a type. `(arg ,n) is not allowed here.
  100.  
  101. ;; For calls from a method:
  102. ; method-gf-call-info:  (method-specializers method-call-info-vector . ???)
  103. ; arg-type:             a type or `(arg ,n)
  104. ; when arg-type is (arg n) the real type is either:
  105. ;   the arg's specializer or
  106. ;   (wrapper-eq ,wrapper) for a call appearing within a caching dfun gf
  107.  
  108. ; every optimized gf in a method has an entry in the method's method-call-info-vector
  109. ; a macro: (get-call-cell mciv-index .all-wrappers.) ->
  110. ;          index into the gf-function-vector
  111.  
  112. ;(defmacro maybe-fast-gf-call (gf-name args)
  113. ;   nil)
  114.  
  115.  
  116. (defun can-optimize-access (form required-parameters env)
  117.   (let ((type (ecase (car form)
  118.         (slot-value 'reader)
  119.         (set-slot-value 'writer)
  120.         (slot-boundp 'boundp)))
  121.     (var (un-the (cadr form)))
  122.     (slot-name (eval (caddr form)))) ; known to be constant
  123.     (when (symbolp var)
  124.       (let* ((rebound? (caddr (variable-declaration 'variable-rebinding var env)))
  125.          (parameter-or-nil (car (memq (or rebound? var) required-parameters))))
  126.     (when parameter-or-nil
  127.       (let* ((class-name (caddr (variable-declaration 
  128.                      'class parameter-or-nil env)))
  129.          (class (find-class class-name nil)))
  130.         (when (if (and class
  131.                (class-on-class-precedence-list-p
  132.                              *the-class-structure-object* class))
  133.               (optimize-slot-value-by-class-p class slot-name type)
  134.               (and class-name (not (eq class-name 't))))
  135.           (cons parameter-or-nil (or class class-name)))))))))
  136.  
  137. (defun optimize-slot-value (generic-function method slots sparameter form)
  138.   (if sparameter
  139.       (destructuring-bind (ignore ignore slot-name-form) form
  140.     (let ((slot-name (eval slot-name-form))
  141.               (class (if (consp sparameter) (cdr sparameter) *the-class-t*))
  142.           (parameter (if (consp sparameter) (car sparameter) sparameter)))
  143.           (if (eq *boot-state* 'complete)
  144.           (optimize-instance-access generic-function method class parameter
  145.                                         slots :read slot-name nil)
  146.               (optimize-std-instance-access class parameter
  147.                                             slots :read slot-name nil))))
  148.       `(fast-slot-value ,@(cdr form))))
  149.  
  150. (defun optimize-set-slot-value (generic-function method slots sparameter form)
  151.   (if sparameter
  152.       (destructuring-bind (ignore ignore slot-name-form new-value) form
  153.     (let ((slot-name (eval slot-name-form))
  154.               (class (if (consp sparameter) (cdr sparameter) *the-class-t*))
  155.           (parameter (if (consp sparameter) (car sparameter) sparameter)))
  156.           (if (eq *boot-state* 'complete)
  157.           (optimize-instance-access generic-function method class parameter
  158.                                     slots :write slot-name new-value)
  159.           (optimize-std-instance-access class parameter
  160.                                         slots :write slot-name new-value))))
  161.       `(fast-set-slot-value ,@(cdr form))))
  162.  
  163. (defun optimize-slot-boundp (generic-function method slots sparameter form)
  164.   (if sparameter
  165.       (destructuring-bind (ignore ignore slot-name-form new-value) form
  166.     (let ((slot-name (eval slot-name-form))
  167.               (class (if (consp sparameter) (cdr sparameter) *the-class-t*))
  168.           (parameter (if (consp sparameter) (car sparameter) sparameter)))
  169.           (if (eq *boot-state* 'complete)
  170.           (optimize-instance-access generic-function method class parameter
  171.                                     slots :boundp slot-name new-value)
  172.           (optimize-std-instance-access class parameter
  173.                                         slots :boundp slot-name new-value))))
  174.       `(fast-slot-boundp ,@(cdr form))))
  175.  
  176. ;;;
  177. ;;; The <slots> argument is an alist, the CAR of each entry is the name of
  178. ;;; a required parameter to the function.  The alist is in order, so the
  179. ;;; position of an entry in the alist corresponds to the argument's position
  180. ;;; in the lambda list.
  181. ;;; 
  182.  
  183. (defun optimize-std-instance-access (class parameter slots read/write
  184.                                      slot-name new-value)
  185.   (let* ((parameter-entry (assq parameter slots))
  186.          (class-name      (if (symbolp class) class (class-name class)))
  187.          (slot-entry      (assq slot-name (cdr parameter-entry)))
  188.          (index-name
  189.            (or (second slot-entry)
  190.                (intern
  191.                 (string-append "." (symbol-name parameter) "-"
  192.                                (symbol-name slot-name) "-INDEX.")))))
  193.     (unless parameter-entry
  194.       (error "Internal error in slot optimization."))
  195.     (unless (or slot-entry
  196.                 (skip-fast-slot-access-p
  197.                   class-name slot-name
  198.                   (ecase read/write
  199.                     (:read 'reader) (:write 'writer) (:boundp 'boundp))))
  200.       (setq slot-entry (list slot-name index-name))
  201.       (push slot-entry (cdr parameter-entry)))
  202.     (ecase read/write
  203.       (:read
  204.        (if slot-entry
  205.            `(instance-read   ,parameter ',slot-name ,index-name ,class-name)
  206.            `(fast-slot-value ,parameter ',slot-name)))
  207.       (:write
  208.        (if slot-entry
  209.            `(instance-write ,parameter ',slot-name ,index-name ,class-name
  210.                             ,new-value)
  211.            `(fast-set-slot-value ,parameter ',slot-name ,new-value)))
  212.       (:boundp
  213.        (if slot-entry
  214.            `(instance-boundp  ,parameter ',slot-name ,index-name ,class-name)
  215.            `(fast-slot-boundp ,parameter ',slot-name))))))
  216.  
  217.  
  218. ;; It is safe for these two functions to be wrong.
  219. ;; They just try to guess what the most likely case will be.
  220. (defun generate-fast-class-slot-access-p (class-form slot-name-form)
  221.   (let ((class (and (constantp class-form) (eval class-form)))
  222.     (slot-name (and (constantp slot-name-form) (eval slot-name-form))))
  223.     (and (eq *boot-state* 'complete)
  224.      (standard-class-p class)
  225.      (not (eq class *the-class-t*)) ; shouldn't happen, though.
  226.      (let ((slotd (find-slot-definition class slot-name)))
  227.            (and slotd (consp (slot-definition-location slotd)))))))
  228.  
  229. (defun skip-fast-slot-access-p (class-name slot-name-form type)
  230.   (let ((class (find-class class-name nil))
  231.     (slot-name
  232.           (cond ((symbolp slot-name-form) slot-name-form)
  233.                 ((constantp slot-name-form) (eval slot-name-form)))))
  234.     (and (eq *boot-state* 'complete)
  235.      (standard-class-p class)
  236.      (not (eq class *the-class-t*)) ; shouldn't happen, though.
  237.          (progn
  238.            (unless (class-finalized-p class) (finalize-inheritance class))
  239.        (let ((slotd (find-slot-definition class slot-name)))
  240.          (and slotd (skip-optimize-slot-value-by-class-p class slot-name type)))))))
  241.  
  242. (defun skip-optimize-slot-value-by-class-p (class slot-name type)
  243.   (let ((slotd (find-slot-definition class slot-name)))
  244.     (and slotd
  245.      (eq *boot-state* 'complete)
  246.      (not (the boolean (slot-accessor-std-p slotd type))))))
  247.  
  248. (defmacro instance-read (parameter slot-name index class)
  249.   (if (skip-fast-slot-access-p class slot-name 'reader)
  250.       `(fast-slot-value ,parameter ,slot-name)
  251.       `(optimized-parameter-read ,parameter ,slot-name ,index)))
  252.  
  253. (defmacro instance-write (parameter slot-name index class new-value)
  254.   (if (skip-fast-slot-access-p class slot-name 'writer)
  255.       `(fast-set-slot-value ,parameter ,slot-name ,new-value)
  256.       `(optimized-parameter-write ,parameter ,slot-name ,index ,new-value)))
  257.  
  258. (defmacro instance-boundp (parameter slot-name index class)
  259.   (if (skip-fast-slot-access-p class slot-name 'boundp)
  260.       `(fast-slot-boundp ,parameter ,slot-name)
  261.       `(optimized-parameter-boundp ,parameter ,slot-name ,index)))
  262.  
  263.  
  264. ;;; closure-generators are used only by method-function-for-caching
  265. ;;; (in methods.lisp) and make-not-for-caching-method-function.
  266.  
  267. (defun make-not-for-caching-method-function (closure-generator)
  268.   (let ((function (method-function-funcall closure-generator nil)))
  269.     #+(and kcl turbo-closure) (si:turbo-closure function)
  270.     function))
  271.  
  272. (declaim (ftype (function (T) boolean) all-standard-accesses-p))
  273. (defun all-standard-accesses-p (slot-locs-and-fetchers-and-method)
  274.   (let ((slot-locations (first  slot-locs-and-fetchers-and-method))
  275.         (slot-fetchers  (second slot-locs-and-fetchers-and-method)))
  276.     (and slot-locations
  277.          slot-fetchers
  278.          (every #'integerp slot-locations)
  279.          (every #'(lambda (x) (eq x 'std-instance-slots)) slot-fetchers))))
  280.  
  281. (defun make-std-closure-generator-form
  282.        (generic-function method optimized-method-lambda initargs)
  283.   (declare (type list initargs))
  284.   (let ((slot-indices
  285.           (getf initargs :optimized-slot-indices))
  286.         (runtime-compile-p
  287.           (and (eq *boot-state* 'complete)
  288.                (call-store-optimized-method-lambda-p
  289.                  generic-function method initargs))))
  290.    (declare (type boolean runtime-compile-p))
  291.    `#'(lambda (slot-locs-and-fetchers-and-method)
  292.         (let (,@(mapcar
  293.                   #'(lambda (slot-index)
  294.                       `(,(third slot-index)
  295.                         (nth ,(posq slot-index slot-indices)
  296.                              (the list
  297.                                   (car slot-locs-and-fetchers-and-method)))))
  298.                   slot-indices))
  299.           (if (all-standard-accesses-p slot-locs-and-fetchers-and-method)
  300.               (macrolet
  301.                 ((optimized-parameter-read (x slot-name index)
  302.                    `(locally (declare #.*optimize-speed*)
  303.                       (let ((.value. (%svref (std-instance-slots ,x) ,index)))
  304.                         (if (eq .value. *slot-unbound*)
  305.                             (funcall #'slot-value ,x ,slot-name)
  306.                             .value.))))
  307.                  (optimized-parameter-write (x slot-name index new)
  308.                    (declare (ignore slot-name))
  309.                    `(locally (declare #.*optimize-speed*)
  310.                       (setf (%svref (std-instance-slots ,x) ,index) ,new)))
  311.                  (optimized-parameter-boundp (x slot-name index)
  312.                    (declare (ignore slot-name))
  313.                    `(locally (declare #.*optimize-speed*)
  314.                       (neq (%svref (std-instance-slots ,x) ,index)
  315.                            *slot-unbound*))))
  316.                (function ,optimized-method-lambda))
  317.              ,(if runtime-compile-p
  318.                   `(make-cached-method-function-from-stored-lambda
  319.                       (third slot-locs-and-fetchers-and-method)
  320.                       slot-locs-and-fetchers-and-method)
  321.                 `(macrolet
  322.                    ((optimized-parameter-read (x slot-name index)
  323.                      `(locally (declare #.*optimize-speed*)
  324.                         (let ((.value.
  325.                                 (typecase ,index
  326.                                   (fixnum (%svref (get-slots ,x) ,index))
  327.                                   (cons   (cdr ,index))
  328.                                   (T      *slot-unbound*))))
  329.                           (if (eq .value. *slot-unbound*)
  330.                               (funcall #'slot-value ,x ,slot-name)
  331.                               .value.))))
  332.                     (optimized-parameter-write (x slot-name index new)
  333.                       (once-only (new)
  334.                        `(locally (declare #.*optimize-speed*)
  335.                           (typecase ,index
  336.                             (fixnum (setf (%svref (get-slots ,x) ,index) ,new))
  337.                             (cons   (setf (cdr ,index) ,new))
  338.                             (T (funcall #'set-slot-value ,x ,slot-name
  339.                                         ,new))))))
  340.                     (optimized-parameter-boundp (x slot-name index)
  341.                       `(locally (declare #.*optimize-speed*)
  342.                          (typecase ,index
  343.                            (fixnum (neq (%svref (get-slots ,x) ,index)
  344.                                         *slot-unbound*))
  345.                            (cons   (neq (cdr ,index) *slot-unbound*))
  346.                            (T      (funcall #'slot-boundp ,x ,slot-name))))))
  347.                   (function ,optimized-method-lambda))))))))
  348.  
  349.  
  350. (defmethod wrapper-fetcher ((class standard-class))
  351.   'std-instance-wrapper)
  352.  
  353. (defmethod slots-fetcher ((class standard-class))
  354.   'std-instance-slots)
  355.  
  356. (defmethod raw-instance-allocator ((class standard-class))
  357.   '%%allocate-instance--class)
  358.  
  359.  
  360. (defun instance-type (instance)
  361.   "Returns the underlying instance type of INSTANCE."
  362.   (cond ((std-instance-p instance)  'std-instance)
  363.         ((fsc-instance-p instance)  'fsc-instance)
  364.         #+pcl-user-instances
  365.         ((user-instance-p instance) 'user-instance)
  366.         ((structurep      instance) 'structure-instance)
  367.         (T (error "~S is not a standard kind of instance." instance))))
  368.  
  369. (defun class-instance-type (class)
  370.   "Returns the underlying instance type CLASS instances."
  371.   (if (eq class *the-class-standard-generic-function*)
  372.       'fsc-instance
  373.       (if (class-finalized-p class)
  374.           (instance-type (class-prototype class))
  375.           (instance-type (allocate-instance class)))))
  376.  
  377. ;;;
  378. ;;;   These are the basic functions to allow programmers to define their
  379. ;;; own type of instances other than STD-INSTANCE, FSC-INSTANCE,
  380. ;;; STRUCTURE-INSTANCE, or BUILT-IN-INSTANCE.  It can be used for user-defined
  381. ;;; meta-classes whose instances' underlying implementation is different
  382. ;;; than the default PCL implementation of STD-INSTANCE for STANDARD-CLASS.
  383. ;;; For example, the programmer can define their own user instances to be
  384. ;;; represented as a simple-vector whose first element stores the information
  385. ;;; needed to control the instances (e.g. a user wrapper storing the normal
  386. ;;; PCL wrapper, the list of slot names for the class, and so on), and whose
  387. ;;; remaining elements are the slots of the instance itself.  This kind of
  388. ;;; defined user instance would take less space than the normal pcl
  389. ;;; STD-INSTANCE (which is represented as a structure, one of whose elements
  390. ;;; is another vector holding the slots), at the cost of some redefinition
  391. ;;; flexibility.  See user-instances.lisp for an example of how this can be done.
  392. ;;;   Defining USER-INSTANCES requires knowledge of how PCL's
  393. ;;; wrappers and slots work internally, but the basic functions that need
  394. ;;; to be implemented are USER-INSTANCE-P, USER-INSTANCE-WRAPPER,
  395. ;;; SET-USER-INSTANCE-WRAPPER, USER-INSTANCE-SLOTS, and
  396. ;;; SET-USER-INSTANCE-SLOTS.  These are analogous to STD-INSTANCE-P,
  397. ;;; STD-INSTANCE-WRAPPER, etc., and must return the same thing that they
  398. ;;; would.
  399. ;;;   Contact Trent Lange (lange@cs.ucla.edu) for any questions.
  400. ;;; The feature :PCL-USER-INSTANCES must be pushed onto the lisp *FEATURES*
  401. ;;; list in low.lisp to turn this feature on.
  402. ;;;
  403.  
  404. #+pcl-user-instances
  405. (progn
  406. (proclaim '(notinline user-instance-p
  407.                       user-instance-wrapper
  408.                       user-instance-slots
  409.                       set-user-instance-wrapper
  410.                       set-user-instance-slots))
  411.  
  412. (defun user-instance-p (x)
  413.   (declare (ignore x))
  414.   NIL)
  415.  
  416. (defun user-instance-wrapper (x)
  417.   (declare (ignore x))
  418.   (error "No user-instance-wrapper function defined for user instances."))
  419.  
  420. (defun set-user-instance-wrapper (x nv)
  421.   (declare (ignore x nv))
  422.   (error "No set-user-instance-wrapper function defined for user instances."))
  423.  
  424. (defun user-instance-slots (x)
  425.   (declare (ignore x))
  426.   (error "No user-instance-slots function defined for user instances."))
  427.  
  428. (defun set-user-instance-slots (x nv)
  429.   (declare (ignore x nv))
  430.   (error "No set-user-instance-slots function defined for user instances."))
  431.  
  432. (defsetf user-instance-wrapper set-user-instance-wrapper)
  433. (defsetf user-instance-slots   set-user-instance-slots)
  434.  
  435. ;;; The following three macros are used by PCL as hooks to call the three
  436. ;;; user-instance functions.  They can be redefined for particular
  437. ;;; instantiations of the user-instance instances to return the same
  438. ;;; values the functions would, but to work faster by avoiding the
  439. ;;; function call.
  440.  
  441. (defmacro get-user-instance-p (x)
  442.   `(user-instance-p ,x))
  443.  
  444. (defmacro get-user-instance-wrapper (x)
  445.   `(user-instance-wrapper ,x))
  446.  
  447. (defmacro get-user-instance-slots (x)
  448.   `(user-instance-slots ,x))
  449.  
  450. (defmacro fast-check-user-wrapper-validity (object)
  451.   `(fast-check-wrapper-validity ,object get-user-instance-wrapper))
  452.  
  453. ) ;+pcl-user-instances
  454.  
  455.